home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / uts / hasegawa / cmpinclude.h next >
C/C++ Source or Header  |  1987-05-08  |  10KB  |  467 lines
  1. /*
  2. (C) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. */
  4. #include <stdio.h>
  5. #include <setjmp.h>
  6. #define    TRUE    1
  7. #define    FALSE    0
  8. typedef int bool;
  9. typedef int fixnum;
  10. typedef float shortfloat;
  11. typedef double longfloat;
  12. typedef union lispunion *object;
  13. #define    OBJNULL    ((object)NULL)
  14. struct fixnum_struct {
  15.     short    t, m;
  16.     fixnum    FIXVAL;
  17. };
  18. #define    fix(x)    (x)->FIX.FIXVAL
  19. #define    SMALL_FIXNUM_LIMIT    1024
  20. struct fixnum_struct small_fixnum_table[];
  21. #define    small_fixnum(i)    (object)(small_fixnum_table+SMALL_FIXNUM_LIMIT+(i))
  22. struct shortfloat_struct {
  23.     short        t, m;
  24.     shortfloat    SFVAL;
  25. };
  26. #define    sf(x)    (x)->SF.SFVAL
  27. struct longfloat_struct {
  28.     short        t, m;
  29.     longfloat    LFVAL;
  30. };
  31. #define    lf(x)    (x)->LF.LFVAL
  32. struct character {
  33.     short        t, m;
  34.     unsigned short    ch_code;
  35.     unsigned char    ch_font;
  36.     unsigned char    ch_bits;
  37. };
  38. struct character character_table[];
  39. #define    code_char(c)    (object)(character_table+(c))
  40. #define    char_code(x)    (x)->ch.ch_code
  41. #define    char_font(x)    (x)->ch.ch_font
  42. #define    char_bits(x)    (x)->ch.ch_bits
  43. enum stype {
  44.     stp_ordinary,
  45.     stp_constant,
  46.         stp_special
  47. };
  48. struct symbol {
  49.     short    t, m;
  50.     object    s_dbind;
  51.     int    (*s_sfdef)();
  52. #define    s_fillp        st_fillp
  53. #define    s_self        st_self
  54.     int    s_fillp;
  55.     char    *s_self;
  56.     object    s_gfdef;
  57.     object    s_plist;
  58.     object    s_hpack;
  59.     short    s_stype;
  60.     short    s_mflag;
  61. };
  62. struct cons {
  63.     short    t, m;
  64.     object    c_cdr;
  65.     object    c_car;
  66. };
  67. struct array {
  68.     short    t, m;
  69.     short    a_rank;
  70.     short    a_adjustable;
  71.     int    a_dim;
  72.     int    *a_dims;
  73.     object    *a_self;
  74.     object    a_displaced;
  75.     short    a_elttype;
  76.     short    a_offset;
  77. };
  78. struct vector {
  79.     short    t, m;
  80.     short    v_hasfillp;
  81.     short    v_adjustable;
  82.     int    v_dim;
  83.     int    v_fillp;
  84.     object    *v_self;
  85.     object    v_displaced;
  86.     short    v_elttype;
  87.     short    v_offset;
  88. };
  89. struct string {
  90.     short    t, m;
  91.     short    st_hasfillp;
  92.     short    st_adjustable;
  93.     int    st_dim;
  94.     int    st_fillp;
  95.     char    *st_self;
  96.     object    st_displaced;
  97. };
  98. struct ustring {
  99.     short    t, m;
  100.     short    ust_hasfillp;
  101.     short    ust_adjustable;
  102.     int    ust_dim;
  103.     int    ust_fillp;
  104.     unsigned char
  105.         *ust_self;
  106.     object    ust_displaced;
  107. };
  108. struct bitvector {
  109.     short    t, m;
  110.     short    bv_hasfillp;
  111.     short    bv_adjustable;
  112.     int    bv_dim;
  113.     int    bv_fillp;
  114.     char    *bv_self;
  115.     object    bv_displaced;
  116.     short    bv_elttype;
  117.     short    bv_offset;
  118. };
  119. struct fixarray {
  120.     short    t, m;
  121.     short    fixa_rank;
  122.     short    fixa_adjustable;
  123.     int    fixa_dim;
  124.     int    *fixa_dims;
  125.     fixnum    *fixa_self;
  126.     object    fixa_displaced;
  127.     short    fixa_elttype;
  128.     short    fixa_offset;
  129. };
  130. struct sfarray {
  131.     short    t, m;
  132.     short    sfa_rank;
  133.     short    sfa_adjustable;
  134.     int    sfa_dim;
  135.     int    *sfa_dims;
  136.     shortfloat
  137.         *sfa_self;
  138.     object    sfa_displaced;
  139.     short    sfa_elttype;
  140.     short    sfa_offset;
  141. };
  142. struct lfarray {
  143.     short    t, m;
  144.     short    lfa_rank;
  145.     short    lfa_adjustable;
  146.     int    lfa_dim;
  147.     int    *lfa_dims;
  148.     longfloat
  149.         *lfa_self;
  150.     object    lfa_displaced;
  151.     short    lfa_elttype;
  152.     short    lfa_offset;
  153. };
  154. struct structure {
  155.     short    t, m;
  156.     object    str_name;
  157.     object    *str_self;
  158.     int    str_length;
  159. };
  160. struct cfun {
  161.     short    t, m;
  162.     object    cf_name;
  163.     int    (*cf_self)();
  164.     object    cf_data;
  165.     char    *cf_start;
  166.     int    cf_size;
  167. };
  168. struct cclosure {
  169.     short    t, m;
  170.     object    cc_name;
  171.     int    (*cc_self)();
  172.     object    cc_env;
  173.     object    cc_data;
  174.     char    *cc_start;
  175.     int    cc_size;
  176.     object    *cc_turbo;
  177. };
  178. struct dummy {
  179.     short    t, m;
  180. };
  181. union lispunion {
  182.     struct fixnum_struct
  183.             FIX;
  184.     struct shortfloat_struct
  185.             SF;
  186.     struct longfloat_struct
  187.             LF;
  188.     struct character
  189.             ch;
  190.     struct symbol    s;
  191.     struct cons    c;
  192.     struct array    a;
  193.     struct vector    v;
  194.     struct string    st;
  195.     struct ustring    ust;
  196.     struct bitvector
  197.             bv;
  198.     struct structure
  199.             str;
  200.     struct cfun    cf;
  201.     struct cclosure    cc;
  202.     struct dummy    d;
  203.     struct fixarray    fixa;
  204.     struct sfarray    sfa;
  205.     struct lfarray    lfa;
  206. };
  207. enum type {
  208.     t_cons = 0,
  209.     t_start = t_cons,
  210.     t_fixnum,
  211.     t_bignum,
  212.     t_ratio,
  213.     t_shortfloat,
  214.     t_longfloat,
  215.     t_complex,
  216.     t_character,
  217.     t_symbol,
  218.     t_package,
  219.     t_hashtable,
  220.     t_array,
  221.     t_vector,
  222.     t_string,
  223.     t_bitvector,
  224.     t_structure,
  225.     t_stream,
  226.     t_random,
  227.     t_readtable,
  228.     t_pathname,
  229.     t_cfun,
  230.     t_cclosure,
  231.     t_spice,
  232.     t_end,
  233.     t_contiguous,
  234.     t_relocatable,
  235.     t_other
  236. };
  237. #define    type_of(obje)    ((enum type)(((object)(obje))->d.t))
  238. #define    endp(obje)    endp1(obje)
  239. object value_stack[];
  240. #define    vs_org        value_stack
  241. object *vs_limit;
  242. object *vs_base;
  243. object *vs_top;
  244. #define    vs_push(obje)    (*vs_top++ = (obje))
  245. #define    vs_pop        (*--vs_top)
  246. #define    vs_head        vs_top[-1]
  247. #define    vs_mark        object *old_vs_top = vs_top
  248. #define    vs_reset    vs_top = old_vs_top
  249. #define    vs_check    if (vs_top >= vs_limit)  \
  250.                 vs_overflow();
  251. #define    vs_check_push(obje)  \
  252.             (vs_top >= vs_limit ?  \
  253.              (object)vs_overflow() : (*vs_top++ = (obje)))
  254. #define    check_arg(n)  \
  255.             if (vs_top - vs_base != (n))  \
  256.                 check_arg_failed(n)
  257. #define    MMcheck_arg(n)  \
  258.             if (vs_top - vs_base < (n))  \
  259.                 too_few_arguments();  \
  260.             else if (vs_top - vs_base > (n))  \
  261.                 too_many_arguments()
  262. #define vs_reserve(x)    if(vs_base+(x) >= vs_limit)  \
  263.                 vs_overflow();
  264. struct bds_bd {
  265.     object    bds_sym;
  266.     object    bds_val;
  267. };
  268. struct bds_bd bind_stack[];
  269. #define bds_org        bind_stack
  270. typedef struct bds_bd *bds_ptr;
  271. bds_ptr bds_limit;
  272. bds_ptr bds_top;
  273. #define    bds_check  \
  274.     if (bds_top >= bds_limit)  \
  275.         bds_overflow()
  276. #define    bds_bind(sym, val)  \
  277.     ((++bds_top)->bds_sym = (sym),  \
  278.     bds_top->bds_val = (sym)->s.s_dbind,  \
  279.     (sym)->s.s_dbind = (val))
  280. #define    bds_unwind1  \
  281.     ((bds_top->bds_sym)->s.s_dbind = bds_top->bds_val, --bds_top)
  282. typedef struct invocation_history {
  283.     object    ihs_function;
  284.     object    *ihs_base;
  285. } *ihs_ptr;
  286. struct invocation_history ihs_stack[];
  287. #define ihs_org        ihs_stack
  288. ihs_ptr ihs_limit;
  289. ihs_ptr ihs_top;
  290. #define    ihs_check  \
  291.     if (ihs_top >= ihs_limit)  \
  292.         ihs_overflow()
  293. #define ihs_push(function)  \
  294.     (++ihs_top)->ihs_function = (function);  \
  295.     ihs_top->ihs_base = vs_base
  296. #define ihs_pop()     (ihs_top--)
  297. enum fr_class {
  298.     FRS_CATCH,
  299.     FRS_CATCHALL,
  300.     FRS_PROTECT
  301. };
  302. struct frame {
  303.     jmp_buf        frs_jmpbuf;
  304.     object        *frs_lex;
  305.     bds_ptr        frs_bds_top;
  306.     enum fr_class    frs_class;
  307.     object        frs_val;
  308.     ihs_ptr        frs_ihs;
  309. };
  310. typedef struct frame *frame_ptr;
  311. #define    alloc_frame_id()    alloc_object(t_spice)
  312. struct frame frame_stack[];
  313. #define frs_org        frame_stack
  314. frame_ptr frs_limit;
  315. frame_ptr frs_top;
  316. #define frs_push(class, val)  \
  317.     if (++frs_top >= frs_limit)  \
  318.         frs_overflow();  \
  319.     frs_top->frs_lex = lex_env;\
  320.     frs_top->frs_bds_top = bds_top;  \
  321.     frs_top->frs_class = (class);  \
  322.     frs_top->frs_val = (val);  \
  323.     frs_top->frs_ihs = ihs_top;  \
  324.         setjmp(frs_top->frs_jmpbuf)
  325. #define frs_pop()    frs_top--
  326. bool nlj_active;
  327. frame_ptr nlj_fr;
  328. object nlj_tag;
  329. object *lex_env;
  330. object caar();
  331. object cadr();
  332. object cdar();
  333. object cddr();
  334. object caaar();
  335. object caadr();
  336. object cadar();
  337. object caddr();
  338. object cdaar();
  339. object cdadr();
  340. object cddar();
  341. object cdddr();
  342. object caaaar();
  343. object caaadr();
  344. object caadar();
  345. object caaddr();
  346. object cadaar();
  347. object cadadr();
  348. object caddar();
  349. object cadddr();
  350. object cdaaar();
  351. object cdaadr();
  352. object cdadar();
  353. object cdaddr();
  354. object cddaar();
  355. object cddadr();
  356. object cdddar();
  357. object cddddr();
  358. #define MMcons(a,d)    make_cons((a),(d))
  359. #define MMcar(x)    (x)->c.c_car
  360. #define MMcdr(x)    (x)->c.c_cdr
  361. #define CMPcar(x)    (x)->c.c_car
  362. #define CMPcdr(x)    (x)->c.c_cdr
  363. #define CMPcaar(x)    (x)->c.c_car->c.c_car
  364. #define CMPcadr(x)    (x)->c.c_cdr->c.c_car
  365. #define CMPcdar(x)    (x)->c.c_car->c.c_cdr
  366. #define CMPcddr(x)    (x)->c.c_cdr->c.c_cdr
  367. #define CMPcaaar(x)    (x)->c.c_car->c.c_car->c.c_car
  368. #define CMPcaadr(x)    (x)->c.c_cdr->c.c_car->c.c_car
  369. #define CMPcadar(x)    (x)->c.c_car->c.c_cdr->c.c_car
  370. #define CMPcaddr(x)    (x)->c.c_cdr->c.c_cdr->c.c_car
  371. #define CMPcdaar(x)    (x)->c.c_car->c.c_car->c.c_cdr
  372. #define CMPcdadr(x)    (x)->c.c_cdr->c.c_car->c.c_cdr
  373. #define CMPcddar(x)    (x)->c.c_car->c.c_cdr->c.c_cdr
  374. #define CMPcdddr(x)    (x)->c.c_cdr->c.c_cdr->c.c_cdr
  375. #define CMPcaaaar(x)    (x)->c.c_car->c.c_car->c.c_car->c.c_car
  376. #define CMPcaaadr(x)    (x)->c.c_cdr->c.c_car->c.c_car->c.c_car
  377. #define CMPcaadar(x)    (x)->c.c_car->c.c_cdr->c.c_car->c.c_car
  378. #define CMPcaaddr(x)    (x)->c.c_cdr->c.c_cdr->c.c_car->c.c_car
  379. #define CMPcadaar(x)    (x)->c.c_car->c.c_car->c.c_cdr->c.c_car
  380. #define CMPcadadr(x)    (x)->c.c_cdr->c.c_car->c.c_cdr->c.c_car
  381. #define CMPcaddar(x)    (x)->c.c_car->c.c_cdr->c.c_cdr->c.c_car
  382. #define CMPcadddr(x)    (x)->c.c_cdr->c.c_cdr->c.c_cdr->c.c_car
  383. #define CMPcdaaar(x)    (x)->c.c_car->c.c_car->c.c_car->c.c_cdr
  384. #define CMPcdaadr(x)    (x)->c.c_cdr->c.c_car->c.c_car->c.c_cdr
  385. #define CMPcdadar(x)    (x)->c.c_car->c.c_cdr->c.c_car->c.c_cdr
  386. #define CMPcdaddr(x)    (x)->c.c_cdr->c.c_cdr->c.c_car->c.c_cdr
  387. #define CMPcddaar(x)    (x)->c.c_car->c.c_car->c.c_cdr->c.c_cdr
  388. #define CMPcddadr(x)    (x)->c.c_cdr->c.c_car->c.c_cdr->c.c_cdr
  389. #define CMPcdddar(x)    (x)->c.c_car->c.c_cdr->c.c_cdr->c.c_cdr
  390. #define CMPcddddr(x)    (x)->c.c_cdr->c.c_cdr->c.c_cdr->c.c_cdr
  391. #define CMPfuncall    funcall
  392. #define    cclosure_call    funcall
  393. object simple_lispcall();
  394. object simple_lispcall_no_event();
  395. object simple_symlispcall();
  396. object simple_symlispcall_no_event();
  397. object CMPtemp;
  398. object CMPtemp1;
  399. object CMPtemp2;
  400. object CMPtemp3;
  401. #define    Cnil    ((object)&Cnil_body)
  402. #define    Ct    ((object)&Ct_body)
  403. struct symbol Cnil_body, Ct_body;
  404. object MF();
  405. object MM();
  406. object Scons;
  407. object siSfunction_documentation;
  408. object siSvariable_documentation;
  409. object siSpretty_print_format;
  410. object Slist;
  411. object keyword_package;
  412. object alloc_object();
  413. object car();
  414. object cdr();
  415. object list();
  416. object listA();
  417. object coerce_to_string();
  418. object elt();
  419. object elt_set();
  420. frame_ptr frs_sch();
  421. frame_ptr frs_sch_catch();
  422. object make_cclosure();
  423. object nth();
  424. object nthcdr();
  425. object make_cons();
  426. object append();
  427. object nconc();
  428. object reverse();
  429. object nreverse();
  430. object number_expt();
  431. object number_minus();
  432. object number_negate();
  433. object number_plus();
  434. object number_times();
  435. object one_minus();
  436. object one_plus();
  437. object get();
  438. object getf();
  439. object putprop();
  440. object remprop();
  441. object string_to_object();
  442. object symbol_function();
  443. object symbol_value();
  444. object make_fixnum();
  445. object make_shortfloat();
  446. object make_longfloat();
  447. object structure_ref();
  448. object structure_set();
  449. object princ();
  450. object prin1();
  451. object print();
  452. object terpri();
  453. object aref();
  454. object aset();
  455. object aref1();
  456. object aset1();
  457. char object_to_char();
  458. int object_to_int();
  459. float object_to_float();
  460. double object_to_double();
  461. int FIXtemp;
  462. #define    CMPmake_fixnum(x) \
  463. ((((FIXtemp=(x))+1024)&-2048)==0?small_fixnum(FIXtemp):make_fixnum(FIXtemp))
  464. #define Creturn(v) return((vs_top=vs,(v)))
  465. #define Cexit return((vs_top=vs,0))
  466. double sin(), cos(), tan();
  467.